home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / tpio24.zip / IO24DEMO.PAS < prev   
Pascal/Delphi Source File  |  1993-01-04  |  19KB  |  604 lines
  1. {$R-}    {Range checking off}
  2. {$B-}    {Boolean short circuiting off}
  3. {$S+}    {Stack checking on}
  4. {$I+}    {I/O checking on}
  5. {$N-}    {No numeric coprocessor}
  6. {$M 16384,0,16384}
  7.  
  8. program IO24DEMO ;
  9.   { This program demonstrates Turbo Pascal console I/O routines for an
  10.     elegant user interface.
  11.       Original version          --  4/18/86.
  12.       Added day of week display -- 10/ 9/86.
  13.       Version 2.2 enhancements  --  5/24/87.
  14.       Ver. 2.3 -- Add screen stuff, set colors -- IBM only, not CP/M.
  15.       Converted to Turbo Pascal 4.0 -- 12/2/87
  16.       Ver. 2.4 -- IO24 -- 8/5/88
  17.  
  18.     PUBLIC DOMAIN, NO COPYRIGHT
  19.       William Meacham
  20.       1004 Elm Street
  21.       Austin, Tx  78703 }
  22.  
  23. {$v-}
  24.  
  25. Uses
  26.   Crt, printer, Dos, io24, date24 ;
  27.  
  28. const
  29.     config_fname     = 'IO24.CFG' ;            { Config file name }
  30.  
  31. type
  32.     config_rec = record
  33.       { Configuration record }
  34.         bgc,                                   { 0 -- background color }
  35.         txc    : integer ;                     { 1 -- text color }
  36.         cfgint : array [2..63] of integer ;    { reserved for future use }
  37.       end ;
  38.  
  39. var
  40.     today       : datestring ;
  41.     choice      : integer ;                    { to get menu choice }
  42.     quitnow     : boolean ;                    { to get user Y/N input }
  43.     config      : config_rec ;                 { Configuration record }
  44.     config_file : file of config_rec ;         { Configuration file }
  45.  
  46. { ------------------------------------------------------------ }
  47.  
  48. procedure title_screen ;
  49.  
  50. var
  51.     ch : char ;
  52.     i  : integer ;
  53.  
  54.     begin
  55.         clrscr;
  56.         write_str ('------------------',31,6) ;
  57.         write_str ('                  ',31,7) ;
  58.         rvson ;
  59.         write_str ('   Demonstration  ',31,8) ;
  60.         write_str ('        of        ',31,9) ;
  61.         write_str ('   Turbo Pascal   ',31,10) ;
  62.         write_str ('  User Interface  ',31,11) ;
  63.         rvsoff ;
  64.         write_str ('                  ',31,12) ;
  65.         write_str ('------------------',31,13) ;
  66.         write_str ('    Reliance Software Services',23,18) ;
  67.         write_str ('1004 Elm Street, Austin, Tx  78703',23,19) ;
  68.         write_str ('   Public Domain - No Copyright',23,21) ;
  69.         fld := 0 ;
  70.         hard_pause ;
  71.         if fld = maxint then
  72.           begin
  73.             gotoxy (1,23) ;
  74.             halt
  75.           end
  76.     end ; { proc title_screen }
  77.  
  78. { ------------------------------------------------------------ }
  79.  
  80. procedure display_menu ;
  81. begin
  82.     clrscr ;
  83.     write_str(today,35,1) ;
  84.     write_str('USER INTERFACE DEMONSTRATION',26,3) ;
  85.     write_str('MAIN MENU',36,4) ;
  86.     write_str('Please select:',26,6) ;
  87.     write_str('1    Display instructions',26,8) ;
  88.     write_str('2    Data entry and display demo for',26,10) ;
  89.     write_str('Strings, Integers, Reals and Booleans',31,11) ;
  90.     write_str('3    Data entry and display demo for Dates',26,13) ;
  91.     write_str('4    Change colors',26,15) ;
  92.     write_str('ESC  Exit the program',26,17) ;
  93.     write_str('==>',26,19)
  94. end ; { proc display_menu }
  95.  
  96. { ------------------------------------------------------------ }
  97.  
  98. procedure display_instructions ;
  99. begin
  100.     clrscr;
  101.     rvson ;
  102.     write_str('                              Labelled     Arrow   Ctrl     Function ',6,1) ;
  103.     write_str('COMMAND                         key         key    key      key (IBM)',6,2) ;
  104.     rvsoff ;
  105.     writeln ;
  106.     writeln('     --------------------------    --------     -----   ----     ---------') ;
  107.     writeln('  *  DELETE character at cursor      Del                  G') ;
  108.     writeln('  *  DELETE character to left      Backspace') ;
  109.     writeln('  *  DELETE entire entry                                  Y         F2') ;
  110.     writeln ;
  111.     writeln('  *  MOVE LEFT one character                    left      S         F5') ;
  112.     writeln('  *  MOVE RIGHT one character                   right     D         F6') ;
  113.     writeln ;
  114.     writeln('  *  MOVE FORWARD to next field     Enter       down      X         F4') ;
  115.     writeln('  *  MOVE BACK to previous field                 up       E         F3') ;
  116.     writeln ;
  117.     writeln('  *  PAGE FORWARD to next screen                PgDn      C         F8') ;
  118.     writeln('  *  PAGE BACK to previous screen               PgUp      R         F7') ;
  119.     writeln ;
  120.     writeln('  *  CANCEL data entry               Esc') ;
  121.     writeln ;
  122.     writeln('  *  TO ENTER DATA:   Type the data & press Enter or a field or page key.') ;
  123.     writeln('  *  TO ENTER YES/NO: Type "Y" or "N;" don''t press Enter.') ;
  124.     writeln('  *  TO ENTER A DATE: Type the month, 2 digits, the day, 2 digits,') ;
  125.     writeln('                      and the year, 2 or 4 digits, and press Enter.') ;
  126.     hard_pause ;
  127.     fld := 1 { reset FLD for calling proc }
  128. end ; { proc display_instructions }
  129.  
  130. { ------------------------------------------------------------ }
  131.  
  132. procedure io_demo ;
  133.   { demonstrate I/O of strings, integers, reals and booleans }
  134.  
  135. var
  136.     first, last, addr1, addr2, city,
  137.           state, zip : str_type ;   { for string demo }
  138.     i1, i2, i3, itot : integer ;    { for integer demo }
  139.     r1, r2, r3, rtot : real ;       { for real demo }
  140.     b1, b2, b3, b4   : boolean ;    { for boolean demo }
  141.  
  142. { ==================== }
  143.  
  144. procedure init_io_vars ;
  145.   { Initializes global variables }
  146.     begin
  147.         first := '' ;
  148.         last  := '' ;
  149.         addr1 := '' ;
  150.         addr2 := '' ;
  151.         city  := '' ;
  152.         state := '' ;
  153.         zip   := '' ;
  154.         i1 := 0 ;
  155.         i2 := 0 ;
  156.         i3 := 0 ;
  157.         itot := 0 ;
  158.         r1 := 0 ;
  159.         r2 := 0 ;
  160.         r3 := 0 ;
  161.         rtot := 0 ;
  162.         b1 := false ;
  163.         b2 := false ;
  164.         b3 := false ;
  165.         b4 := false
  166.     end ; { proc init_io_vars }
  167.  
  168. { ==================== }
  169.  
  170. procedure strings ;
  171.   { This procedure demonstrates reading and writing strings. }
  172.  
  173.     var
  174.         i  : integer ; { For loop control }
  175.         ok : boolean ; { Whether zip code is numeric }
  176.  
  177.     begin
  178.         clrscr ;
  179.         rvson ;
  180.         write ('SCREEN ', scrn, ' -- STRINGS') ;
  181.         rvsoff ;
  182.         write_str ('First name:',9,8) ;
  183.         write_str (first,21,8 ) ;
  184.         write_str ('Last name:',9,9) ;
  185.         write_str (last,21,9) ;
  186.         write_str ('Address 1:',9,10) ;
  187.         write_str (addr1,21,10) ;
  188.         write_str ('Address 2:',9,11) ;
  189.         write_str (addr2,21,11) ;
  190.         write_str ('City:',9,12) ;
  191.         write_str (city,21,12) ;
  192.         write_str ('State:',9,13) ;
  193.         write_str (state,21,13) ;
  194.         write_str ('Zip:',9,14) ;
  195.         write_str (zip,21,14) ;
  196.         fld := 1 ;
  197.         repeat
  198.                 case fld of
  199.                   1: read_str (first, 15, 21, 8) ;
  200.                   2: read_str (last, 10, 21, 9) ;
  201.                   3: read_str (addr1, 15, 21, 10) ;
  202.                   4: read_str (addr2, 15, 21, 11) ;
  203.                   5: read_str (city, 15, 21, 12) ;
  204.                   6: read_str (state, 2, 21, 13) ;
  205.                   7: begin
  206.                        repeat
  207.                            read_str (zip, 5, 21, 14) ;
  208.                            ok := true ;
  209.                            if not (zip = '') then
  210.                                begin
  211.                                    if length (zip) < 5 then
  212.                                            ok := false
  213.                                    else
  214.                                            for i:= 1 to 5 do
  215.                                                if (zip[i] <'0')
  216.                                                or (zip[i] >'9') then
  217.                                                    ok := false
  218.                                end ;
  219.                            if not ok then
  220.                              begin
  221.                                show_msg ('MUST BE NUMERIC OR NOT ENTERED') ;
  222.                                zip := '' ;
  223.                                fld := 7
  224.                              end
  225.                        until ok ;
  226.                      end ; { 7: }
  227.                 end ; { case }
  228.         until (fld < 1) or (fld > 7) ;
  229.         do_scrn_ctl
  230.     end ; { proc strings }
  231.  
  232. { ==================== }
  233.  
  234. procedure integers ;
  235.   { This procedure demonstrates reading & writing integers. }
  236.  
  237.     procedure sum_int ;
  238.         begin
  239.             itot := i1 + i2 + i3 ;
  240.             write_int (itot, 5, 13, 12)
  241.         end ;
  242.  
  243.     begin { integers }
  244.         clrscr ;
  245.         rvson ;
  246.         write ('SCREEN ', scrn, ' -- INTEGERS') ;
  247.         rvsoff ;
  248.         write_str ('==>', 9, 8) ;
  249.         write_int (i1,4,14,8) ;
  250.         write_str ('==>', 9, 9) ;
  251.         write_int (i2,4,14,9) ;
  252.         write_str ('==>', 9, 10) ;
  253.         write_int (i3,4,14,10) ;
  254.         write_str ('TOTAL', 7, 12) ;
  255.         write_int (itot,5,13,12) ;
  256.         fld := 1 ;
  257.         repeat
  258.                 case fld of
  259.                   1: begin
  260.                        read_int (i1, 4, 14, 8) ;
  261.                        sum_int ;
  262.                      end ;
  263.                   2: begin
  264.                        read_int (i2, 4, 14, 9) ;
  265.                        sum_int ;
  266.                      end ;
  267.                   3: begin
  268.                        read_int (i3, 4, 14, 10) ;
  269.                        sum_int ;
  270.                      end ;
  271.                   4: pause ;
  272.                 end ; { case }
  273.         until (fld < 1) or (fld > 4 ) ;
  274.         do_scrn_ctl
  275.     end ; { proc integers }
  276.  
  277. { ==================== }
  278.  
  279. procedure reals ;
  280.   { This procedure demonstrates reading & writing reals. }
  281.  
  282.     const
  283.         tot  = 11 ;
  284.         frac = 3  ;
  285.  
  286.     procedure sum_real ;
  287.         begin
  288.             rtot := r1 + r2 + r3 ;
  289.             write_real (rtot, tot+1, frac, 13, 12)
  290.         end ;
  291.  
  292.     begin { proc reals }
  293.         clrscr ;
  294.         rvson ;
  295.         write ('SCREEN ', scrn, ' -- REALS') ;
  296.         rvsoff ;
  297.         write_str ('==>', 9, 8) ;
  298.         write_real (r1,tot,frac,14,8) ;
  299.         write_str ('==>', 9, 9) ;
  300.         write_real (r2,tot,frac,14,9) ;
  301.         write_str ('==>', 9, 10) ;
  302.         write_real (r3,tot,frac,14,10) ;
  303.         write_str ('TOTAL', 7, 12) ;
  304.         write_real (rtot,12,3,13,12) ;
  305.         fld := 1 ;
  306.         repeat
  307.                 case fld of
  308.                   1: begin
  309.                        read_real (r1, tot,frac, 14, 8) ;
  310.                        sum_real ;
  311.                      end ;
  312.                   2: begin
  313.                        read_real (r2, tot,frac, 14, 9) ;
  314.                        sum_real ;
  315.                      end ;
  316.                   3: begin
  317.                        read_real (r3, tot,frac, 14, 10) ;
  318.                        sum_real ;
  319.                      end ;
  320.                   4: pause ;
  321.                 end ; { CASE }
  322.         until (fld < 1) or (fld > 4 ) ;
  323.         do_scrn_ctl
  324.     end ; { proc reals }
  325.  
  326. { ==================== }
  327.  
  328. procedure booleans ;
  329.   { This procedure demonstrates reading & writing booleans }
  330.     begin
  331.         clrscr;
  332.         rvson ;
  333.         write ('SCREEN ', scrn, ' -- BOOLEANS') ;
  334.         rvsoff ;
  335.         write_str ('TYPE OF CO-BORROWER.  Type "Y" for all that apply.',3,8) ;
  336.         write_str ('"No" will be assumed if you just press <RETURN>.',3,9) ;
  337.         write_str ('1 - Another person will be jointly obligated with borrower',5,10) ;
  338.         write_str ('2 - Borrower is relying on income of another person',5,11) ;
  339.         write_str ('3 - Married, living in a community property state',5,12) ;
  340.         write_bool (b1, 71, 10) ;
  341.         write_bool (b2, 71, 11) ;
  342.         write_bool (b3, 71, 12) ;
  343.         write_str ('Epimenides the Cretan says, "All Cretans are liars!"  Is he lying?',3,14) ;
  344.         write_bool (b4, 71, 14) ;
  345.         fld := 1 ;
  346.         repeat
  347.             case fld of
  348.               1: read_bool (b1, 71, 10) ;
  349.               2: read_bool (b2, 71, 11) ;
  350.               3: read_bool (b3, 71, 12) ;
  351.               4: read_bool (b4, 71, 14) ;
  352.               5: pause ;
  353.             end ; { case }
  354.         until (fld <1) or (fld > 5) ;
  355.         do_scrn_ctl
  356.     end ; { booleans }
  357.  
  358. { ==================== }
  359.  
  360. procedure final_screen ;
  361.   { The final screen -- demonstrates proc Read_YN }
  362.     var
  363.         more : boolean ;
  364.     begin
  365.         clrscr ;
  366.         write_str ('End of demonstration.',20, 10) ;
  367.         write_str ('Do it again?',20, 12) ;
  368.         read_yn (more, 34, 12) ;
  369.         if more then
  370.             scrn := 1
  371.         else
  372.             scrn := succ(scrn)
  373.     end ; { proc final_screen }
  374.  
  375. { ==================== }
  376.  
  377. begin { ----- proc io_demo ----- }
  378.     scrn := 1 ;
  379.     init_io_vars ;
  380.     repeat
  381.         case scrn of
  382.           1 : strings  ;
  383.           2 : integers ;
  384.           3 : reals ;
  385.           4 : booleans ;
  386.           5 : final_screen
  387.         end ; { case }
  388.         if scrn < 1 then
  389.               scrn := 1           { no going backward from first screen }
  390.         else if scrn > 6 then
  391.               scrn := 5           { trap ESC }
  392.     until scrn > 5 ;
  393.     fld := 1 ;                    { reset FLD for calling proc }
  394. end ; { proc io_demo }
  395.  
  396. { ------------------------------------------------------------ }
  397.  
  398. {$i datedemo.inc -- procedure date_demo }
  399.  
  400. { ------------------------------------------------------------ }
  401.  
  402. function exists (filename : str14) : boolean ;
  403.   { test to see if file exists }
  404. var
  405.     infile : file ;
  406. begin
  407.     assign (infile,filename) ;
  408.     {$i-} reset(infile) {$i+} ;
  409.     if ioresult = 0 then
  410.       begin
  411.         exists := true ;
  412.         close (infile)
  413.       end
  414.     else
  415.         exists := false
  416. end ; { function exists }
  417.  
  418. {------------------------------------------------------------- }
  419.  
  420. procedure set_colors ;
  421.  
  422. label 99 ;   { for ESC exit }
  423.  
  424. var
  425.     n,
  426.     savebgcolor,
  427.     savetxcolor : integer ;
  428.     color_ok    : boolean ;
  429.  
  430. { -------------------- }
  431.  
  432. procedure paint_color_screen ;
  433.   begin
  434.     clrscr ;
  435.     write_str ('CHANGE COLORS',34,1) ;
  436.     write_str ('Please enter your choice of colors or',22,3) ;
  437.     write_str ('press ESC to cancel.',22,4) ;
  438.     write_str ('DARK COLORS       BRIGHT COLORS',22,6) ;
  439.     write_str ('--------------    -------------------',22,7) ;
  440.     write_str ('0 - Black         8  - Dark Grey',22,8) ;
  441.     write_str ('1 - Blue          9  - Bright Blue',22,9) ;
  442.     write_str ('2 - Green         10 - Bright Green',22,10) ;
  443.     write_str ('3 - Cyan          11 - Bright Cyan',22,11) ;
  444.     write_str ('4 - Red           12 - Bright Red',22,12) ;
  445.     write_str ('5 - Magenta       13 - Bright Magenta',22,13) ;
  446.     write_str ('6 - Brown         14 - Yellow',22,14) ;
  447.     write_str ('7 - Light Grey    15 - White',22,15) ;
  448.     rvson ;
  449.     write_str ('This is reverse video',22,17) ;
  450.     rvsoff ;
  451.     emphon ;
  452.     write_str ('This is emphasized',22,18) ;
  453.     emphoff ;
  454.     write_str ('Background color (0-7):',28,20) ;
  455.     write_int (bgcolor,1,52,20) ;
  456.     write_str ('Text color (0-15):',28,21) ;
  457.     write_int (txcolor,2,51,21)
  458.   end ;
  459.  
  460. { -------------------- }
  461.  
  462. begin { proc set_colors }
  463.     paint_color_screen ;
  464.     if is_mono then
  465.       begin
  466.         show_msg ('YOU CANNOT CHANGE COLORS ON A MONOCHROME MONITOR') ;
  467.         exit
  468.       end ;
  469.  
  470.     savebgcolor := bgcolor ;                 { save entry values }
  471.     savetxcolor := txcolor ;
  472.     fld := 1 ;
  473.     repeat
  474.         case fld of
  475.           1: read_int (bgcolor,1,52,20) ;
  476.           2: read_int (txcolor,2,51,21) ;
  477.           3: begin
  478.                assigncolors ;
  479.                paint_color_screen ;
  480.                write_str ('Is this OK? (Y/N)',28,23) ;
  481.                color_ok := false ;
  482.                read_bool (color_ok,50,23) ;
  483.                if not (fld = maxint) then
  484.                    if fld > 3 then
  485.                      begin
  486.                        if color_ok then
  487.                            fld := 4       { normal exit }
  488.                        else
  489.                            fld := 1
  490.                      end ;
  491.                clrline(28,23)
  492.              end { 3 }
  493.         end ; { case }
  494.         if fld = maxint then goto 99 ;    { ESC exits }
  495.         if fld < 1 then
  496.             fld := 1
  497.         else if not (bgcolor in [0..7]) then
  498.           begin
  499.             beep ;
  500.             fld := 1
  501.           end
  502.         else if (not (txcolor in [0..15])) and (fld > 2) then
  503.           begin
  504.             beep ;
  505.             fld := 2
  506.           end
  507.         else if (fld > 4) then
  508.             fld := 3 ;
  509. 99:
  510.     until fld > 3 ;
  511.     if fld = maxint then                     { restore entry values }
  512.       begin
  513.         bgcolor := savebgcolor ;
  514.         txcolor := savetxcolor ;
  515.         assigncolors
  516.       end
  517.     else if not ((bgcolor = savebgcolor) and (txcolor = savetxcolor)) then
  518.       begin
  519.         config.bgc := bgcolor ;              { store defaults in config file }
  520.         config.txc := txcolor ;
  521.         for n := 2 to 63 do
  522.             config.cfgint[n] := 0 ;
  523.         rewrite (config_file) ;
  524.         write (config_file,config) ;
  525.         close (config_file)
  526.       end ;
  527.     fld := 1
  528.   end ; { proc set_colors }
  529.  
  530. { ------------------------------------------------------------ }
  531.  
  532. procedure initialize ;
  533.  
  534. var
  535.     dosdate : date ;
  536.  
  537. begin  { proc initialize }
  538.     assign (config_file, config_fname) ;
  539.     if (exists (config_fname)) and (not is_mono) then
  540.       begin
  541.         reset (config_file) ;
  542.         read  (config_file,config) ;
  543.         close (config_file) ;
  544.         bgcolor := config.bgc ;
  545.         txcolor := config.txc
  546.       end
  547.     else
  548.       begin
  549.         bgcolor := 0 ;
  550.         txcolor := 7
  551.       end ;
  552.     assigncolors ;
  553.     getdate(dosdate) ;
  554.     today := mk_dt_st(dosdate)
  555.   end ; { proc initialize }
  556.  
  557. { ------------------------------------------------------------ }
  558.  
  559. begin { --- program IO24DEMO --- }
  560. (*  directvideo := false { uncomment this to avoid conflicts with Fansi-Console, etc. }
  561. *)
  562.     checkbreak := false ;
  563.     initialize ;
  564.     title_screen ;
  565.     repeat
  566.         display_menu ;
  567.         repeat
  568.             fld := 1 ;
  569.             choice := 0 ;
  570.             read_int (choice,1, 31,19) ;
  571.             if fld < 1 then choice := 0 ;
  572.             if fld = maxint then
  573.               begin
  574.                 write_str (' ',31,19) ;
  575.                 write_str ('QUIT NOW? (Y/N)',26,21) ;
  576.                 read_yn (quitnow,42,21) ;
  577.                 if not quitnow then
  578.                   begin
  579.                     fld := 1 ;
  580.                     choice := 0 ;
  581.                     clrline (26,21)
  582.                   end
  583.               end ;
  584.         until (choice in [1 .. 4]) or (fld = maxint) ;
  585.         if not (fld = maxint) then
  586.             case choice of
  587.               1: display_instructions ;
  588.               2: io_demo ;
  589.               3: date_demo ;
  590.               4: set_colors
  591.             else
  592.                  beep
  593.             end  { case }
  594.     until fld = maxint ;
  595.     clrscr ;
  596.     write_str ('Thank you for trying the Reliance User Interface Demonstration',12,5) ;
  597.     write_str ('Program.  Please send me your comments and suggestions.',12,6) ;
  598.     write_str ('Bill Meacham',30,10) ;
  599.     write_str ('Reliance Software Services',24,11) ;
  600.     write_str ('1004 Elm Street',29,12) ;
  601.     write_str ('Austin, Tx  78703',28,13) ;
  602.     writeln ; writeln
  603. end.
  604.